     Baraj ziua 3 (Selectie lot IOI, Cluj, mai 1996)
                       Problema 2 (Statui)

     Primarul unui ora dorete s[ amplaseze ct mai multe statui, cel mult una ntr-o pia[. Oraul
este vizitat de diverse oficialit[i care sosesc la aeroport i trebuie transportate la prim[rie pe un drum
de lungime minim[. Primarul dorete s[ poat[ transporta oaspeii astfel nct, fie s[ vad[ toate statuile,
fie s[ nu vad[ nici o statuie.
    Cunoscnd reeaua stradal[ i poziiile aeroportului i prim[riei n aceast[ reea, s[ se determine
unde trebuie plasate statuile i care sunt cele dou[ trasee, astfel nct num[rul statuilor s[ fie maxim.
Intrarea:
    Datele de intrare se citesc dintr-un fiier al c[rui nume se d[ de la tastatur[. Fiierul conine:
- pe prima linie num[rul n de piee din ora; prim[ria se afl[ n piaa num[rul 1, aeroportul n piaa
cu num[rul n(n150);
- pe urm[toarele n linii se g[sesc cte n numere ntregi nenegative; al j-lea num[r de pe a i-a linie
reprezeint[ lungimea str[zii de la piaa avnd num[rul i la piaa cu num[rul j sau 0 dac[ i=j sau nu
exist[ strad[. datorit[ sensurilor unice, se poate ca distana de la i la j s[ nu fie egal[ cu distana de
la j la i.
    Datele din fiierul de intrare asigur[ existena cel puin a unui drum ntre aeroport i prim[rie.
ieirea:
    Ieirea se face ntr-un fiier text al c[rui nume se citete de la tastatur[. acest fiier va conine:
- pe prima linie num[rul s de statui urmat de lista pieelor n care urmeaz[ a fi amplasate;
- pe a doua linie num[rul de piee de pe drumul f[r[ statui, urmat de lista pieelor, n ordine, de la
aeroport la prim[rie (inclusiv capetele);
- pe a treia linie num[rul de piee de pe drumul ce viziteaz[ toate statuile, urmat de lista pieelor, n
ordine, de la aeroport la prim[rie (inclusiv capetele).
    Se cere o singur[ soluie.
Precizare: Att la intrare ct i la ieire datele de pe o linie sunt separate printr-un spaiu.
Exemplu:
Intrare:
5
0 2 0 3 0
2 0 2 2 0
0 2 0 1 2
3 1 0 0 3
0 0 2 3 0
    o ieire corect[:
2 2 3
3 5 4 1
4 5 3 2 1
Not[: Timp de executare maxim: 30 secunde.
    Punctej maxim: 100 puncte.
==============================================
Solutia 1 (Mihai Badoiu):
{$A+,B-,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V+,X+,Y-}
{$M 65520,0,655360}
const
    max=150;

type
    tip=array[1..max,1..max] of byte;

var
    n11,n12,n22,n21:integer;
    n:integer;
    dist:integer;
    max_statuie:integer;
    v,vi:array[1..max,1..max] of byte;
    tt,tt2:array[1..max] of byte;
    d11,d12,d21,d22:array[1..max] of byte;
    vs:array[1..max] of byte;
    r:array[1..max] of integer;
    timp:longint absolute $0:$46c;
    t:^tip;

procedure load;
var
    f:text;
    nume:string;
    i,j:integer;
begin
    write('fisier intrare = ');
    readln(nume);
    assign(f,nume);
    reset(f);
    readln(f,n);
    for i:=1 to n do
    begin
             for j:=1 to n do
             begin
                           read(f,v[i,j]);
                           if (v[i,j]=0) then
                                              v[i,j]:=200;
                           if i=j then
                                              v[i,j]:=0;
                           end;
             readln(f);
             end;
    close(f);
end;

procedure calcul;
var
    i,j,k:integer;
begin
    {Floyd}
    for k:=1 to n do
             for i:=1 to n do
                           for j:=1 to n do
                           if v[i,k]+v[k,j]<v[i,j] then
                                              v[i,j]:=v[i,k]+v[k,j];
    dist:=v[n,1];
{              for i:=1 to n do
             if v[n,i]+v[i,1]=dist then
             for j:=1 to n do
             begin
                           if v[n,j]+v[j,1]=dist then
                           begin
                                              for k:=1 to n do
                                              begin
                                                                      if (v[n,k]<v[n,j]) then
                                                                      begin
                                                                                                   if t^[k,j]<t^[i,j]+1 then
                                                                                                                                     t^[k,j]:=t^[i,j]+1;
                                                                                                   end;
                                                                      if (v[n,i]<v[n,k]) and (v[n,j]<v[n,i]) then
                                                                      begin
                                                                                                   if t^[i,k]<t^[i,j] then
                                                                                                                                     t^[i,k]:=t^[i,j];
                                                                                                   end;
                                                                      end;
                                              end;
                           end;}
end;

procedure scrie;
var
    nume:string;
    f:text;
    i:integer;
begin
    write('numele fis. de iesire = ');
    readln(nume);
    assign(f,nume);
    rewrite(f);
    write(f,max_statuie);
    for i:=1 to max_statuie do
             write(f,' ',tt2[i]);
    writeln(f);
    write(f,n12+1,' ',n);
    for i:=1 to n12 do
    begin
             write(f,' ',d12[i]);
             end;
    writeln(f);
    write(f,n22+1,' ',n);
    for i:=1 to n22 do
    begin
             write(f,' ',d22[i]);
             end;
    close(f);
end;

procedure init;
var
    i,j:integer;
begin
    for i:=1 to n do
             for j:=1 to n do
                           t^[i,j]:=0;
end;

procedure scs(st:integer);
begin
    if max_statuie<st then
    begin
             max_statuie:=st;
             tt2:=tt;
             d12:=d11;
             d22:=d21;
             n22:=n21;
             n12:=n11;
             end;
    if timp>500 then
    begin
             scrie;
             halt;
             end;
end;

procedure bk2(p:integer;st:integer);
var
    i:integer;
begin
    if p=1 then
             scs(st)
    else
    begin
{           if r[p]>st+2 then
                           exit;
             if r[p]<st then
                           r[p]:=st;}
             for i:=1 to n do
             if vs[i]<2 then
                           if (v[n,p]+vi[p,i]+v[i,1]=dist) then
                           begin
                                              inc(vs[i]);
                                              inc(n21);
                                              d21[n21]:=i;
                                              if vs[i]=1 then
                                              begin
                                                                      tt[st+1]:=i;
                                                                                                                             bk2(i,st+1)
                                                                      end
                                              else
                                                                      bk2(i,st);
                                              dec(n21);
                                              dec(vs[i]);
                                              end;
             end;
end;

procedure bk1(p:integer);
var
    i:integer;
begin
    if p=1 then
    begin
             bk2(n,0);
             end
    else
    begin
             for i:=1 to n do
             if vs[i]=0 then
                           if v[n,p]+vi[p,i]+v[i,1]=dist then
                           begin
                                              vs[i]:=1;
                                              inc(n11);
                                              d11[n11]:=i;
                                              bk1(i);
                                              dec(n11);
                                              vs[i]:=0;
                                              end;
             end;
end;

procedure calcul_dr;
begin
    vs[n]:=1;
    bk1(n);
end;

begin
    max_statuie:=-1;
    new(t);
    load;
    timp:=0;
    vi:=v;
    init;
    calcul;
    calcul_dr;
    scrie;
end.
-------------------------------
Solutia 2 (Catalin Francu):
program Statui;
{$B-,I-,R-,S-}
const NMax=150;
type ByteMatrix=array[1..NMax,1..NMax] of Byte;
     IntegerMatrix=array[1..NMax,1..NMax] of Integer;
     ByteVector=array[1..NMax] of Byte;
var D:IntegerMatrix;
    SaveD:^IntegerMatrix;
    NS,F,SaveNS,SaveF:^ByteMatrix;
    RStat,RNStat:ByteVector;
    N,NStat,NNStat:Integer;
    SO:String;

procedure ReadData;
var i,j:Integer;
    S:String;
begin
  Write('Numele fisierului de intrare: ');ReadLn(S);
  New(NS);New(F);New(SaveD);New(SaveNS);New(SaveF);
  Write('Numele fisierului de iesire: ');ReadLn(SO);
  Assign(Input,S);Reset(Input);
  ReadLn(N);
  for i:=1 to N do
    begin
      for j:=1 to N do
        begin
          Read(D[i,j]);
          if D[i,j]=0
            then begin
                   if i<>j then D[i,j]:=MaxInt;
                   F^[i,j]:=0;
                   NS^[i,j]:=0;
                 end
            else begin
                   F^[i,j]:=i;
                   NS^[i,j]:=1;
                 end;
        end;
      ReadLn;
    end;
  Close(Input);
  SaveD^:=D;
  SaveNS^:=NS^;
  SaveF^:=F^;
end;

procedure FloydMax;
var i,j,k:Integer;
begin
  for k:=1 to N do
    for i:=1 to N do
      for j:=1 to N do
        if (D[i,k]<>MaxInt) and (D[k,j]<>MaxInt)
          then if (D[i,k]+D[k,j]<D[i,j])
                 or ((D[i,k]+D[k,j]=D[i,j]) and (NS^[i,k]+NS^[k,j]>NS^[i,j]))
                 then begin
                        D[i,j]:=D[i,k]+D[k,j];
                        F^[i,j]:=k;
                        NS^[i,j]:=NS^[i,k]+NS^[k,j];
                      end;
end;

procedure Floyd;
var i,j,k:Integer;
begin
  for k:=1 to N do
    for i:=1 to N do
      for j:=1 to N do
        if (D[i,k]<>MaxInt) and (D[k,j]<>MaxInt)
          then if (D[i,k]+D[k,j]<D[i,j])
                 then begin
                        D[i,j]:=D[i,k]+D[k,j];
                        F^[i,j]:=k;
                        NS^[i,j]:=NS^[i,k]+NS^[k,j];
                      end;
end;

procedure FindStatueWay;
var K:Integer;
begin
  K:=N;NStat:=0;
  while K<>1 do begin
                  Inc(NStat);
                  RStat[NStat]:=K;
                  K:=F^[1,K];
                end;
  Inc(NStat);
  RStat[NStat]:=1;
end;

procedure FindNoStatueWay;
var K:Integer;
begin
  if D[1,N]=MaxInt
    then NNStat:=0
    else begin
           K:=N;NNStat:=0;
           while K<>1 do begin
                           Inc(NNStat);
                           RNStat[NNStat]:=K;
                           K:=F^[1,K];
                         end;
           Inc(NNStat);
           RNStat[NNStat]:=1;
         end;
end;

procedure Restore;
var i,j:Integer;
begin
  D:=SaveD^;
  NS^:=SaveNS^;
  F^:=SaveF^;
  for i:=2 to NStat-1 do
    for j:=1 to N do
      begin
        if i<>j then begin
                       D[RStat[i],j]:=MaxInt;
                       D[j,RStat[i]]:=MaxInt;
                     end;
        NS^[i,j]:=0;
        NS^[j,i]:=0;
        F^[i,j]:=0;
        F^[j,i]:=0;
      end;
end;

procedure WriteSolution;
var i:Integer;
begin
  Assign(Output,SO);Rewrite(Output);
  Write(NStat-2,' ');
  for i:=NStat-1 downto 2 do Write(RStat[i],' ');
  WriteLn;
  Write(NNStat,' ');
  for i:=1 to NNStat do Write(RNStat[i],' ');
  WriteLn;
  Write(NStat,' ');
  for i:=1 to NStat do Write(RStat[i],' ');
  WriteLn;
  Close(Output);
end;

begin
  ReadData;
  FloydMax;
  FindStatueWay;
  Restore;
  Floyd;
  FindNoStatueWay;
  WriteSolution;
end.
--------------------------------------
Solutia 3 (Ovidiu ghiorghioiu):
{$A+,B-,D+,E+,F-,G+,I+,L+,N-,O-,P-,Q-,R-,S-,T-,V+,X+,Y+}
{$M 65000,0,655360}
uses crt;
const nmax=150;
      inf=maxint;
type line=array[1..nmax] of word;
var a:array[1..nmax] of line;
    d:line;
    s,s0:array[1..nmax] of boolean;
    x,xx,x0,xx0:line;
    i,j,k,min,n:word;
    max,ns,n1,n2,n10,n20:integer;
    f:text;
    nf:string;
    t:longint absolute $0:$46c;
    t0:longint;
procedure citeste;
begin
     write('Numele fis. de intrare: ');readln(nf);
     assign(f,nf);
     reset(f);
     read(f,n);
     for i:=1 to n do
         for j:=1 to n do begin
             read(f,k);
             if k=0 then a[i,j]:=inf else a[i,j]:=k
         end;
     close(f);
     write('Numele fis. de iesire: ');readln(nf);
     assign(f,nf);
     rewrite(f);
end;
function minim(i,j:word):word;
begin
     if i>j then minim:=j else minim:=i
end;
procedure scrie;
begin
     if n=1 then begin
        writeln(f,0);
        writeln(f,'1 1');
        writeln(f,'1 1')
     end else begin
         write(f,max);
         for i:=1 to n do if s0[i] then write(f,' ',i);
         writeln(f);
         write(f,n20+2,' ',n);
         for i:=n20 downto 1 do write(f,' ',xx0[i]);
         writeln(f,' 1');
         write(f,n10+2,' ',n);
         for i:=n10 downto 1 do write(f,' ',x0[i]);
         writeln(f,' 1')
     end;
     close(f);
end;
procedure back1(k:word);
var i:word;
    sk:boolean;
begin
     if k=n then begin
        move(x,x0,n1 shl 1);
        move(xx,xx0,n2 shl 1);
        move(s,s0,n);
        max:=ns;
        n10:=n1;
        n20:=n2;
     end else begin
         sk:=s[k];
         if sk then begin
            dec(ns);
            s[k]:=false
         end;
         if ns>max then begin
            inc(n2);
            xx[n2]:=k;
            for i:=n downto 1 do
                if d[k]=d[i]+a[i,k] then back1(i);
            dec(n2);
         end;
         if sk then begin
            inc(ns);
            s[k]:=true
         end;
     end;
     if t>t0 then begin
        scrie;
        halt
     end;
end;
procedure back(k:word);
var i:word;
begin
     if k=n then
        if ns>max then
           for i:=n downto 1 do if d[1]=d[i]+a[i,1] then back1(i) else
        else else begin
           inc(ns);
           inc(n1);
           x[n1]:=k;
           s[k]:=true;
           for i:=2 to n do
               if d[k]=d[i]+a[i,k] then back(i);
           s[k]:=false;
           dec(ns);
           dec(n1);
        end;
     if t>t0 then begin
        scrie;
        halt
     end;
end;
procedure rezolva;
begin
     t0:=t+455;
     d:=a[n];
     d[n]:=0;
     fillchar(s,sizeof(s),true);
     for k:=1 to n-2 do begin
         min:=inf;
         for i:=1 to n-1 do if s[i] then
             if d[i]<min then begin
                min:=d[i];
                j:=i
             end;
         s[j]:=false;
         for i:=1 to n-1 do if s[i] then
             d[i]:=minim(d[i],min+a[j,i])
     end;
     fillchar(s,sizeof(s),false);
     max:=-1;
     ns:=0;
     n2:=0;
     for i:=n-1 downto 1 do if d[1]=d[i]+a[i,1] then back(i);
end;
begin
     citeste;
     rezolva;
     scrie;
end.
-------------------------------------
Solutia 4 (Vlad petric):
program zi3_p2;

type gr=array[1..150,1..150] of integer;

var n:integer;
    graf,d1,d2,rec1,rec2:^gr;


procedure citire;
var f:text;
    nf:string;
    i,j:integer;
begin
  new(graf);
  new(d1);
  new(d2);
  new(rec1);
  new(rec2);
  writeln('Nume fisier:');
  readln(nf);
  assign(f,nf);
  reset(f);
  readln(f,n);
  for i:=1 to n do
    for j:=1 to n do
      read(f,graf^[i,j]);
  d1^:=graf^;
  d2^:=graf^;
  for i:=1 to n do
    for j:=1 to n do begin
      rec1^[i,j]:=0;
      rec2^[i,j]:=0;
      d1^[i,j]:=d1^[i,j]*150;
      d2^[i,j]:=d2^[i,j]*150;

      if d1^[i,j]<>0 then
        inc(d1^[i,j]);
      if d2^[i,j]<>0 then
        dec(d2^[i,j]);
    end;

  end;

procedure floyd1;
var k,i,j:integer;
begin
  for k:=1 to n do
    for i:=1 to n do
      if d1^[i,k]<>0 then
        for j:=1 to n do
          if (d1^[k,j]<>0) and ((d1^[i,k]+d1^[k,j]<d1^[i,j]) or (d1^[i,j]=0)) then begin
            d1^[i,j]:=d1^[i,k]+d1^[k,j];
            rec1^[i,j]:=k;
          end;

end;

procedure floyd2;
var k,i,j:integer;
begin
  for k:=1 to n do
    for i:=1 to n do
      if d2^[i,k]<>0 then
        for j:=1 to n do
          if (d2^[k,j]<>0) and ((d2^[i,k]+d2^[k,j]<d2^[i,j]) or (d2^[i,j]=0)) then begin
            d2^[i,j]:=d2^[i,k]+d2^[k,j];
            rec2^[i,j]:=k;
          end;

end;

var drum1,drum2:array[1..150] of integer;
    p1,p2:integer;

procedure parcurge1(x,y:integer);
begin
  if rec1^[x,y]<>0 then begin
    parcurge1(x,rec1^[x,y]);
    inc(p1);
    drum1[p1]:=rec1^[x,y];
    parcurge1(rec1^[x,y],y);
  end;
end;

procedure parcurge2(x,y:integer);
begin
  if rec2^[x,y]<>0 then begin
    parcurge2(x,rec2^[x,y]);
    inc(p2);
    drum2[p2]:=rec2^[x,y];
    parcurge2(rec2^[x,y],y);
  end;
end;

function exists(x:integer):boolean;
var i:integer;
begin
  for i:=1 to p1 do
    if x=drum1[i] then begin
      exists:=true;
      exit;
    end;
  exists:=false;
end;

procedure tratare;
var stat:array[1..150] of integer;
    i,ns:integer;
    f:text;
    nf:string;
begin
  ns:=0;
  for i:=1 to p2 do
    if not exists(drum2[i]) then begin
      inc(ns);
      stat[ns]:=drum2[i];
    end;
  writeln('Nume fisier ieshire:');
  readln(nf);
  assign(f,nf);
  rewrite(f);
  write(f,ns);
  for i:=1 to ns do
    write(f,' ',stat[i]);
  writeln(f);
  write(f,p1+2,' ',n,' ');
  for i:=1 to p1 do
    write(f,drum1[i],' ');
  writeln(f,1);
  write(f,p2+2,' ',n,' ');
  for i:=1 to p2 do
    write(f,drum2[i],' ');
  write(f,1);
  close(f);
end;

var i,j:integer;

begin
  citire;
  floyd1;
  parcurge1(n,1);
  drum1[p1+1]:=1;
  for i:=1 to p1 do
    for j:=1 to n do
      if d2^[drum1[i],j]<>0 then
        inc(d2^[drum1[i],j]);

  floyd2;
  parcurge2(n,1);
  tratare;
end.
-------------------------------
Stroe

{                        Statui

    O rezolvare de concurs este urmatoarea:
    - se aplica algoritmul lui Dijkstra, modificat pentru obtinea tuturor
    drumurilor minime de la aeroport la primarie ( evident, orasul este un
    graf orientat )
    - se iau drumurile minime doua cite doua si se alege perechea in care
    unul din drumuri are cit mai multe noduri care se gasesc in celalalt
    - in nodurile respective se vor plasa statuile; se afiseaza lista lor
    si cele doua drumuri.

    Pe nu caz cu foarte multe drumuri minime (de ordinul sutelor), programul
  are mari sanse sa nu se incadreze in timp. De exemplu, un graf bipartit
  complet cu 50 de noduri in fiecare partitie, in care se introduce primaria,
  legata prin arc de toate nodurile din prima partitie, si aeroportul, similar
  fata de a doua partitie, daca toate arcele au lungimea 1, sunt 2500 drumuri
  optime; o idee ar fi ca programul sa se opreasca dupa 29 de secunde si sa
  afiseze solutia partiala, care poate fi optima.

}

type sset=set of byte;
var fi,fo:text;
    a,drum:array[0..150,0..150]of byte;
    st,v,d,top,ord:array[0..150]of word;
    se:sset;
    mul,t:array[1..150]of set of byte;
    max,x,y,nr,min,mp,i,j,k,l,m,n:longint;
    luate:set of byte;
    s:string;

procedure finddrum(nrpasi:byte;se:sset);
var i:byte;
begin
  if v[nrpasi]=n then
     begin
       inc(nr);
       top[nr]:=nrpasi;
       for i:=1 to top[nr] do drum[nr,i]:=v[i];
       mul[nr]:=se;
       exit;
     end;
  for i:=1 to n do
      if i in t[v[nrpasi]] then
         begin
           v[nrpasi+1]:=i;
           se:=se+[i];
           finddrum(nrpasi+1,se);
           v[nrpasi+1]:=0;
           se:=se-[i];
         end;
end;

begin
  write('Introduceti numele fisierului de intrare ');
  readln(s);
  assign(fi,s);
  write('Introduceti numele fisierului de iesire ');
  readln(s);
  assign(fo,s);
  reset(fi);
  readln(fi,n);
  for i:=1 to n do
      begin
        for j:=1 to n do
            read(fi,a[i,j]);
        readln(fi);
      end;
  close(fi);
  for i:=1 to n do d[i]:=60000;
  d[n]:=0;
  luate:=[n];
  ord[1]:=n;
  for i:=1 to n do if a[n,i]<>0 then begin d[i]:=a[n,i];t[i]:=[n];end;
  for i:=1 to n-1 do
      begin
        min:=60000;
        for j:=1 to n do
            if(d[j]<min)and(not(j in luate)) then begin min:=d[j];mp:=j;end;
        luate:=luate+[mp];
        ord[i+1]:=mp;
        for j:=1 to n do
            if (a[mp,j]<>0)and(min+a[mp,j]<d[j])then
               begin
                 d[j]:=min+a[mp,j];
                 t[j]:=[mp];
               end
               else
             if (a[mp,j]<>0)and(min+a[mp,j]=d[j])then
                t[j]:=t[j]+[mp];
      end;
  nr:=0;
  v[1]:=1;
  se:=[];
  finddrum(1,se);
  max:=-1;
  x:=0;
  y:=0;
  for i:=1 to nr do
      for j:=1 to nr do
          begin
            m:=0;
            for k:=1 to n do
                if (k in mul[i])and not(k in mul[j]) then inc(m);
            if m>max then
               begin
                 max:=m;
                 x:=i;
                 y:=j;
                 m:=0;
                 for k:=1 to n do
                     if (k in mul[i])and not(k in mul[j]) then
                        begin
                          inc(m);
                          st[m]:=k;
                        end;
               end;
          end;
  rewrite(fo);
  write(fo,max);
  for i:=1 to max do write(fo,' ',st[i]);
  writeln(fo);
  write(fo,top[y]);
  for i:=top[y] downto 1 do write(fo,' ',drum[y,i]);
  writeln(fo);
  write(fo,top[x]);
  for i:=top[x] downto 1 do write(fo,' ',drum[x,i]);
  close(fo);
end.
----------------------------------------
